CU Amiga Super CD-ROM 11/CU Amiga Magazine's Super CD-ROM 11 (1997)(EMAP Images)(GB)(Track 1 of 3)[!][issue 1997-06].iso/cucd/programming/oberonv4/demos/compress.mod

Oberon Text | 1996-02-29 | 30KB | 1,234 lines

Syntax10.Scn.Fnt
MODULE Compress; (* (c) ejz, first version: 14.1.92, this version: 30.11.94 *)
    IMPORT Files, Texts, Oberon, MenuViewers, TextFrames, Viewers;
        CONST
            BufferSize = 8192;
            IndexBitCount = 12;
            LengthBitCount = 4;
            WindowSize = 4096;
            RawLookAheadSize = 16;
            BreakEven = 1;
            LookAheadSize = RawLookAheadSize + BreakEven;
            TreeRoot = WindowSize;
            EndOfStream = 0;
            Unused = 0;
            Temp = "temp.temp";
            err1 = "Error in archive";
            err2 = " not found";
            err3 = " Archive to big";
            err4 = "Filename to long, can not append .bak";
            DirMenu = "System.Close System.Grow Compress.Open Compress.Extract Compress.Delete Compress.Add";
            EditMenu = "System.Close System.Copy System.Grow Edit.Search Edit.Store";
            maxFileSize = 3000000;
            xx = 32768;
            Menu = 0;
            Cmd = 1;
            EOFName = "~ ";
        TYPE
            Node = RECORD
                parent , smallerChild, largerChild: INTEGER
            END;
            fName = ARRAY 32 OF CHAR;
            Header = RECORD
                Name: fName;
                length, Check: LONGINT;
                date, time: LONGINT;
                ratio: REAL
            END;
            List = POINTER TO ListDesc;
            ListDesc = RECORD
                Name: fName;
                next: List
            END;
            AddList = POINTER TO AddListDesc;
            AddListDesc = RECORD
                Name: fName;
                next: AddList;
                pos: LONGINT
            END;
        VAR
            W: Texts.Writer;
            Buffer: ARRAY BufferSize OF CHAR;
            BufferPtr, CurBitNr, Len, maxLen: LONGINT;
            CurByte: LONGINT;
            Window: ARRAY WindowSize+RawLookAheadSize+1 OF CHAR;
            Tree: POINTER TO ARRAY WindowSize+1 OF Node;
            Err, opt, sym: BOOLEAN;
            T: Texts.Text;
            cmdSource: INTEGER;
            help : INTEGER;
        PROCEDURE WriteString(str: ARRAY OF CHAR);
        BEGIN
            Texts.WriteString(W, str);
            Texts.Append(T, W.buf)
        END WriteString;
        PROCEDURE WriteLn;
        BEGIN
            Texts.WriteLn(W);
            Texts.Append(T, W.buf)
        END WriteLn;
        PROCEDURE WriteInt(i: LONGINT);
        BEGIN
            Texts.WriteInt(W, i, 0);
            Texts.Append(T, W.buf)
        END WriteInt;
        PROCEDURE WriteReal(r: REAL);
        BEGIN
            Texts.WriteReal(W, r, 10);
            Texts.Append(T, W.buf)
        END WriteReal;
        PROCEDURE WriteDate(t, d: LONGINT);
        BEGIN
            Texts.WriteDate(W, t, d);
            Texts.Append(T, W.buf)
        END WriteDate;
        PROCEDURE ReadHeader(VAR R: Files.Rider; VAR h: Header; VAR err: BOOLEAN);
            VAR
                i: INTEGER;
                chk: LONGINT;
        BEGIN
            Files.ReadBytes(R, h.Name, 32);
            IF R.eof & (R.res = 32) THEN
                h.Name := EOFName;
                err := FALSE;
                RETURN
            END;
            Files.ReadLInt(R, h.length);
            Files.ReadLInt(R, h.Check);
            Files.ReadLInt(R, h.date);
            Files.ReadLInt(R, h.time);
            Files.ReadReal(R, h.ratio);
            IF (h.ratio > 0.0) & (h.ratio < 1000000.0) THEN
                i := 0;
                chk := 0;
                WHILE i < 32 DO
                    chk := chk+ORD(h.Name[i]);
                    INC(i)
                END;
                chk := chk+h.length+ENTIER(h.ratio)+(h.time MOD xx)+(h.date MOD xx);
                err := chk # h.Check
            ELSE
                err := TRUE
            END
        END ReadHeader;
        PROCEDURE WriteHeader(VAR R: Files.Rider; VAR h: Header; newDate: BOOLEAN);
            VAR i: INTEGER;
        BEGIN
            h.Check := 0;
            i := 0;
            WHILE i < 32 DO
                h.Check := h.Check + ORD(h.Name[i]);
                INC(i)
            END;
            IF newDate THEN
                Oberon.GetClock(h.time, h.date)
            END;
            h.Check := h.Check+h.length+(h.time MOD xx)+(h.date MOD xx)+ENTIER(h.ratio);
            Files.WriteBytes(R, h.Name, 32);
            Files.WriteLInt(R, h.length);
            Files.WriteLInt(R, h.Check);
            Files.WriteLInt(R, h.date);
            Files.WriteLInt(R, h.time);
            Files.WriteReal(R, h.ratio)
        END WriteHeader;
        PROCEDURE CopyFrom(VAR Ri, Ro: Files.Rider; len: LONGINT);
            VAR i: LONGINT;
        BEGIN
            Files.ReadBytes(Ri, Buffer, BufferSize);
            i := BufferSize;
            WHILE i <= len DO
                Files.WriteBytes(Ro, Buffer, BufferSize);
                Files.ReadBytes(Ri, Buffer, BufferSize);
                INC(i, BufferSize)
            END;
            Files.WriteBytes(Ro, Buffer, len MOD BufferSize)
        END CopyFrom;
        PROCEDURE CopyTo(VAR Ri, Ro: Files.Rider);
        BEGIN
            Files.ReadBytes(Ri, Buffer, BufferSize);
            WHILE ~Ri.eof DO
                Files.WriteBytes(Ro, Buffer, BufferSize);
                Files.ReadBytes(Ri, Buffer, BufferSize)
            END;
            Files.WriteBytes(Ro, Buffer, BufferSize-Ri.res)
        END CopyTo;
        PROCEDURE FlushBits(VAR R: Files.Rider);
        BEGIN
            IF CurBitNr # 7 THEN
                Buffer[BufferPtr] := CHR(CurByte);
                INC(BufferPtr)
            END;
            IF BufferPtr > 0 THEN
                Files.WriteBytes(R, Buffer, BufferPtr);
                INC(Len, BufferPtr)
            END
        END FlushBits;
        PROCEDURE InputBit(VAR R: Files.Rider): LONGINT;
            VAR h: LONGINT;
        BEGIN
            IF CurBitNr = 7 THEN
                IF BufferPtr = BufferSize THEN
                    Files.ReadBytes(R, Buffer, BufferSize);
                    INC(Len, BufferSize);
                    IF Len >= maxLen+ BufferSize THEN Err := TRUE END;
                    BufferPtr := 0
                END;
                CurByte := ORD(Buffer[BufferPtr]);
                INC(BufferPtr)
            END;
            h := ASH(CurByte, -CurBitNr) MOD 2;
            DEC(CurBitNr);
            IF CurBitNr < 0 THEN CurBitNr := 7 END;
            RETURN h
        END InputBit;
        PROCEDURE InputBits(VAR R: Files.Rider; count: LONGINT): LONGINT;
            VAR i, h: LONGINT;
        BEGIN
            h := 0;
            i := count-1;
            WHILE i >= 0 DO
                IF CurBitNr = 7 THEN
                    IF BufferPtr = BufferSize THEN
                        Files.ReadBytes(R, Buffer, BufferSize);
                        INC(Len, BufferSize);
                        IF Len > maxLen+ BufferSize THEN Err := TRUE END;
                        BufferPtr := 0
                    END;
                    CurByte := ORD(Buffer[BufferPtr]);
                    INC(BufferPtr)
                END;
                IF ASH(CurByte, -CurBitNr) MOD 2 = 1 THEN
                    h := h+ASH(1, i)
                END;
                DEC(CurBitNr);
                IF CurBitNr < 0 THEN CurBitNr := 7 END;
                DEC(i)
            END;
            RETURN h
        END InputBits;
        PROCEDURE OutputBit(VAR R: Files.Rider; bit: LONGINT);
        BEGIN
            IF bit = 1 THEN
                CurByte := CurByte+ASH(1, CurBitNr)
            END;
            DEC(CurBitNr);
            IF CurBitNr < 0 THEN
                Buffer[BufferPtr] := CHR(CurByte);
                INC(BufferPtr);
                IF BufferPtr = BufferSize THEN
                    Files.WriteBytes(R,  Buffer, BufferSize);
                    INC(Len, BufferSize);
                    BufferPtr := 0
                END;
                CurBitNr := 7;
                CurByte := 0
            END
        END OutputBit;
        PROCEDURE OutputBits(VAR R: Files.Rider; bits, count: LONGINT);
            VAR i, h: LONGINT;
        BEGIN
            h := bits;
            i := count-1;
            WHILE i >= 0 DO
                IF ASH(h, -i) MOD 2 = 1 THEN
                    CurByte := CurByte+ASH(1, CurBitNr)
                END;
                DEC(CurBitNr);
                IF CurBitNr < 0 THEN
                    Buffer[BufferPtr] := CHR(CurByte);
                    INC(BufferPtr);
                    IF BufferPtr = BufferSize THEN
                        Files.WriteBytes(R, Buffer, BufferSize);
                        INC(Len, BufferSize);
                        BufferPtr := 0
                    END;
                    CurBitNr := 7;
                    CurByte := 0
                END;
                DEC(i)
            END
        END OutputBits;
        PROCEDURE Init;
            VAR i: INTEGER;
        BEGIN
            i := 0;
            WHILE i < WindowSize DO
                Tree[i].parent := Unused;
                Tree[i].smallerChild := Unused;
                Tree[i].largerChild := Unused;
                Window[i] := CHR(0);
                INC(i)
            END;
            Tree[i].parent := Unused;
            Tree[i].smallerChild := Unused;
            Tree[i].largerChild := Unused;
            WHILE i < WindowSize+RawLookAheadSize+1 DO
                Window[i] := CHR(0);
                INC(i)
            END
        END Init;
        PROCEDURE InitTree(r: INTEGER);
        BEGIN
            Tree[TreeRoot].largerChild := r;
            Tree[r].parent := TreeRoot;
            Tree[r].largerChild := Unused;
            Tree[r].smallerChild := Unused
        END InitTree;
        PROCEDURE ContractNode(oldNode, newNode: INTEGER);
        BEGIN
            help := Tree[oldNode].parent;
            Tree[newNode].parent := help;
            help := Tree[oldNode].parent;
            IF Tree[help].largerChild = oldNode THEN
                Tree[help].largerChild := newNode
            ELSE
                Tree[help].smallerChild := newNode
            END;
            Tree[oldNode].parent := Unused
        END ContractNode;
        PROCEDURE ReplaceNode(oldNode, newNode: INTEGER);
            VAR parent: INTEGER;
        BEGIN
            parent := Tree[oldNode].parent;
            IF Tree[parent].smallerChild = oldNode THEN
                Tree[parent].smallerChild := newNode
            ELSE
                Tree[parent].largerChild := newNode
            END;
            Tree[newNode] := Tree[oldNode];
            help := Tree[newNode].smallerChild;
            Tree[help].parent := newNode;
            help := Tree[newNode].largerChild;
            Tree[help].parent := newNode;
            Tree[oldNode].parent := Unused
        END ReplaceNode;
        PROCEDURE FindNextNode(node: INTEGER): INTEGER;
            VAR next: INTEGER;
        BEGIN
            next := Tree[node].smallerChild;
            WHILE Tree[next].largerChild # Unused DO
                next := Tree[next].largerChild
            END;
            RETURN next
        END FindNextNode;
        PROCEDURE DeleteString(p: INTEGER);
            VAR replacement: INTEGER;
        BEGIN
            IF Tree[p].parent = Unused THEN
                RETURN
            END;
            IF Tree[p].largerChild = Unused THEN
                ContractNode(p, Tree[p].smallerChild)
            ELSIF Tree[p].smallerChild = Unused THEN
                ContractNode(p, Tree[p].largerChild)
            ELSE
                replacement := FindNextNode(p);
                DeleteString(replacement);
                ReplaceNode(p, replacement)
            END
        END DeleteString;
        PROCEDURE AddString(newNode: INTEGER; VAR matchPosition: INTEGER): INTEGER;
            VAR i, testNode, delta, matchLength, child: INTEGER;
        BEGIN
            IF newNode = EndOfStream THEN
                RETURN 0
            END;
            testNode := Tree[TreeRoot].largerChild;
            matchLength := 0;
            LOOP
                i := 0;
                delta := 0;
                WHILE (i < LookAheadSize) & (delta = 0) DO
                    delta := ORD(Window[newNode+i]) - ORD(Window[testNode+i]);
                    INC(i)
                END;
                IF delta # 0 THEN DEC(i) END;
                IF i >= matchLength THEN
                    matchLength := i;
                    matchPosition := testNode;
                    IF matchLength >= LookAheadSize THEN
                        ReplaceNode(testNode, newNode);
                        RETURN matchLength
                    END;
                END;
                IF delta >= 0 THEN
                    child := Tree[testNode].largerChild
                ELSE
                    child := Tree[testNode].smallerChild
                END;
                IF child = Unused THEN
                    IF delta >= 0 THEN
                        Tree[testNode].largerChild := newNode
                    ELSE
                        Tree[testNode].smallerChild := newNode
                    END;
                    Tree[newNode].parent := testNode;
                    Tree[newNode].largerChild := Unused;
                    Tree[newNode].smallerChild := Unused;
                    RETURN matchLength
                END;
                testNode := child
            END
        END AddString;
        PROCEDURE Compress(VAR Input, Output: Files.Rider);
            VAR
                i, lookAheadBytes, currentPosition, replaceCount, matchLength, matchPosition: INTEGER;
                ch: CHAR;
        BEGIN
            Init;
            currentPosition := 1;
            i := 0;
            WHILE (i < LookAheadSize) & ~Input.eof DO
                Files.Read(Input, ch);
                Window[currentPosition+i] := ch;
                IF currentPosition+i < RawLookAheadSize+1 THEN
                    Window[currentPosition+i+WindowSize-1] := ch
                END;
                INC(i)
            END;
            IF Input.eof THEN DEC(i) END;
            lookAheadBytes := i;
            InitTree(currentPosition);
            matchLength := 0;
            matchPosition := 0;
            WHILE lookAheadBytes > 0 DO
                IF matchLength > lookAheadBytes THEN
                    matchLength := lookAheadBytes
                END;
                IF matchLength <= BreakEven THEN
                    replaceCount := 1;
                    OutputBit(Output, 1);
                    OutputBits(Output, ORD(Window[currentPosition]), 8)
                ELSE
                    OutputBit(Output, 0);
                    OutputBits(Output, matchPosition, IndexBitCount);
                    OutputBits(Output, matchLength-(BreakEven+1), LengthBitCount);
                    replaceCount := matchLength
                END;
                i := 0;
                WHILE i < replaceCount DO
                    DeleteString((currentPosition+LookAheadSize) MOD (WindowSize-1));
                    Files.Read(Input, ch);
                    IF Input.eof THEN
                        DEC(lookAheadBytes)
                    ELSE
                        Window[currentPosition+LookAheadSize] := ch;
                        Window[(currentPosition+LookAheadSize) MOD (WindowSize-1)] := ch
                    END;
                    currentPosition := (currentPosition+1) MOD (WindowSize-1);
                    IF lookAheadBytes # 0 THEN
                        matchLength := AddString(currentPosition, matchPosition)
                    END;
                    INC(i)
                END
            END;
            OutputBit(Output, 0);
            OutputBits(Output, EndOfStream, IndexBitCount)
        END Compress;
        PROCEDURE Expand(VAR Input, Output: Files.Rider);
            VAR
                i, currentPosition, matchLength, matchPosition: INTEGER;
                ch: CHAR;
        BEGIN
            Err := FALSE;
            Init;
            currentPosition := 1;
            LOOP
                IF InputBit(Input) # 0 THEN
                    ch := CHR(InputBits(Input, 8));
                    Files.Write(Output, ch);
                    Window[currentPosition] := ch;
                    IF currentPosition < RawLookAheadSize+1 THEN
                        Window[currentPosition+WindowSize-1] := ch
                    END;
                    currentPosition := (currentPosition+1) MOD (WindowSize-1)
                ELSE
                    matchPosition := SHORT(InputBits(Input, IndexBitCount));
                    IF matchPosition = EndOfStream THEN EXIT END;
                    matchLength := SHORT(InputBits(Input, LengthBitCount));
                    INC(matchLength, BreakEven);
                    i := 0;
                    WHILE i <= matchLength DO
                        ch := Window[matchPosition+i];
                        Files.Write(Output, ch);
                        Window[currentPosition] := ch;
                        IF currentPosition < RawLookAheadSize+1 THEN
                            Window[currentPosition+WindowSize-1] := ch;
                        END;
                        currentPosition := (currentPosition+1) MOD (WindowSize-1);
                        INC(i)
                    END
                END;
                IF Err THEN RETURN END
            END
        END Expand;
        PROCEDURE CopyToArc(VAR f: Files.File; VAR Ro: Files.Rider; VAR ratio: REAL): LONGINT;
            VAR Ri: Files.Rider;
        BEGIN
            Files.Set(Ri, f, 0);
            Len := 0;
            BufferPtr := 0;
            CurBitNr := 7;
            CurByte := 0;
            Compress(Ri, Ro);
            FlushBits(Ro);
            ratio := 100*Len/Files.Length(f);
            RETURN Len
        END CopyToArc;
        PROCEDURE CopyFromArc(VAR Ri: Files.Rider; VAR f: Files.File; len: LONGINT);
            VAR Ro: Files.Rider;
        BEGIN
            maxLen := len;
            Files.Set(Ro, f, 0);
            Len := 0;
            BufferPtr := BufferSize;
            CurBitNr := 7;
            CurByte := 0;
            Expand(Ri, Ro);
            IF Err THEN
                WriteString("Error expanding");
                WriteLn
            END
        END CopyFromArc;
        PROCEDURE StringLen(str: ARRAY OF CHAR): INTEGER;
            VAR i: INTEGER;
        BEGIN
            i := 0;
            WHILE (i < LEN(str)) & (str[i] # CHR(0)) DO
                INC(i)
            END;
            RETURN i
        END StringLen;
        PROCEDURE UpString(VAR str: ARRAY OF CHAR);
            VAR i: INTEGER;
        BEGIN
            i := 0;
            WHILE i < StringLen(str) DO
                IF (str[i] >= "a") & (str[i] <= "z") THEN
                    str[i] := CHR(ORD(str[i])+ORD("A")-ORD("a"))
                END;
                INC(i)
            END
        END UpString;
        PROCEDURE StringConcat(VAR dest: ARRAY OF CHAR; a: ARRAY OF CHAR);
            VAR i, j: INTEGER;
        BEGIN
            i := StringLen(dest);
            j :=  0;
            WHILE (i < LEN(dest)) & (j < StringLen(a)) DO
                dest[i] := a[j];
                INC(i);
                INC(j)
            END;
            IF i < LEN(dest) THEN dest[i] := CHR(0) END
        END StringConcat;
        PROCEDURE Search(NameList: List; VAR Name: fName): List;
        BEGIN
            WHILE NameList # NIL DO
                IF NameList.Name = Name THEN RETURN NameList END;
                NameList := NameList.next
            END;
            RETURN NIL
        END Search;
        PROCEDURE SearchA(NameList: AddList; VAR Name: fName): AddList;
        BEGIN
            WHILE NameList # NIL DO
                IF NameList.Name = Name THEN RETURN NameList END;
                NameList := NameList.next
            END;
            RETURN NIL
        END SearchA;
        PROCEDURE Remove(VAR NameList: List; VAR Name: fName);
            VAR cur, prev: List;
        BEGIN
            cur := NameList.next;
            prev := NameList;
            WHILE cur # NIL DO
                IF cur.Name = Name THEN
                    prev.next := cur.next;
                    RETURN
                ELSE
                    prev := cur
                END;
                cur := cur.next
            END
        END Remove;
        PROCEDURE GetArcName(VAR name: fName);
            VAR
                V: Viewers.Viewer;
                S: Texts.Scanner;
        BEGIN
            V := Oberon.Par.vwr;
            IF (V.dsc IS TextFrames.Frame) & (V.dsc = Oberon.Par.frame) THEN
                Texts.OpenScanner(S, V.dsc(TextFrames.Frame).text, 0);
                Texts.Scan(S);
                IF S.class = Texts.Name THEN
                    cmdSource := Menu;
                    COPY(S.s, name);
                    RETURN
                END
            END;
            cmdSource := Cmd;
            name := EOFName
        END GetArcName;
        PROCEDURE GetText(): Texts.Text;
            VAR
                V: Viewers.Viewer;
        BEGIN
            V := Oberon.Par.vwr;
            IF (V = NIL) OR (V.dsc = NIL) OR (V.dsc.next = NIL) THEN
                RETURN NIL
            ELSIF V.dsc.next IS TextFrames.Frame THEN
                RETURN V.dsc.next(TextFrames.Frame).text
            ELSE
                RETURN NIL
            END
        END GetText;
        PROCEDURE GetArgs(VAR NameList: List);
            VAR
                h, last: List;
                S: Texts.Scanner;
                mn: fName;
                arrow: BOOLEAN;
                T: Texts.Text;
                beg, end, time, pos: LONGINT;
        BEGIN
            pos := 0;
            end := 0;
            arrow := FALSE;
            NameList := NIL;
            last := NIL;
            GetArcName(mn);
            IF mn # EOFName THEN
                arrow := TRUE;
                NEW(h);
                h.next := NIL;
                COPY(mn, h.Name);
                NameList := h;
                last := NameList;
                Oberon.GetSelection(T, beg, end, time);
                IF time > 0 THEN
                    Texts.OpenScanner(S, T, beg); pos := beg; Texts.Scan(S)
                ELSE
                    RETURN
                END
            ELSE
                Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos);
                Texts.Scan(S);
                IF (S.class = Texts.Char) & (S.c = "^") THEN
                    arrow := TRUE;
                    Oberon.GetSelection(T, beg, end, time);
                    IF time > 0 THEN
                        Texts.OpenScanner(S, T, beg); pos := beg; Texts.Scan(S)
                    ELSE
                        RETURN
                    END
                END
            END;
            WHILE ((cmdSource = Menu) &  (pos <= end+StringLen(S.s))) OR
                                ((cmdSource = Cmd) & (S.class = Texts.Name) & (~arrow OR (arrow & (pos <= end+StringLen(S.s))))) DO
                NEW(h);
                h.next := NIL;
                COPY(S.s, h.Name);
                IF Search(NameList, h.Name) = NIL THEN
                    IF last = NIL THEN
                        NameList := h
                    ELSE
                        last.next := h
                    END;
                    last := h
                END;
                Texts.Scan(S);
                IF ~arrow & (S.class = Texts.Char) & (S.c = "^") THEN
                    arrow := TRUE;
                    Oberon.GetSelection(T, beg, end, time);
                    IF time > 0 THEN
                        Texts.OpenScanner(S, T, beg); Texts.Scan(S)
                    END
                END;
                pos := Texts.Pos(S)
            END;
            IF cmdSource = Menu THEN
                opt := TRUE
            ELSE
                opt := FALSE;
                    IF (S.class = Texts.Char) & ((S.c = "/") OR (S.c = "\")) THEN
                        Texts.Scan(S);
                        IF (S.class = Texts.Name) & (S.s[0] = "d") THEN opt := TRUE END;
                    END
            END
        END GetArgs;
        PROCEDURE OpenArchive(VAR NameList: List; warn: BOOLEAN): Files.File;
            VAR ArcF: Files.File;
        BEGIN
            ArcF := Files.Old(NameList.Name);
            IF (ArcF = NIL) & warn THEN
                WriteString("archive: ");
                WriteString(NameList.Name);
                WriteString(err2);
                WriteLn
            END;
            RETURN ArcF
        END OpenArchive;
        PROCEDURE Trimm(VAR name: ARRAY OF CHAR);
            VAR
                l, i, j: LONGINT;
                back: fName;
                ch: CHAR;
        BEGIN
            l := LEN(name);
            j := -1;
            i := 0;
            WHILE (i < l) & (name[i] # 0X) DO
                ch := name[i];
                IF (ch = "/") OR (ch = "\") THEN
                    j := i
                END;
                INC(i)
            END;
            IF j >= 0 THEN
                COPY(name, back);
                j := j+1;
                i := 0;
                WHILE (j < l) & (back[j] # 0X) DO
                    name[i] := back[j];
                    INC(i);
                    INC(j)
                END;
                name[i] := 0X
            END
        END Trimm;
    PROCEDURE NextName(VAR name: ARRAY OF CHAR);
        VAR
            i, l: LONGINT;
            ch: CHAR;
    BEGIN
        l := LEN(name);
        i := 0;
        WHILE (i < l) & (name[i] # 0X) DO
            INC(i)
        END;
        IF i >= l THEN
            name[l-1] := CHR(ORD(name[l-1])+1)
        ELSE
            ch := name[i-1];
            IF (ch >= "0") & (ch <= "8") THEN
                name[i-1] := CHR(ORD(name[i-1])+1)
            ELSE
                name[i] := "0";
                IF (i+1) < l THEN
                    name[i+1] := 0X
                END
            END
        END
    END NextName;
        PROCEDURE Directory*;
            VAR
                NameList: List;
                ArcF: Files.File;
                R: Files.Rider;
                h: Header;
                err, newViewer: BOOLEAN;
                x, y, n: INTEGER;
                V: MenuViewers.Viewer;
                t: Texts.Text;
                totRatio: REAL;
        BEGIN
            GetArgs(NameList);
            IF NameList = NIL THEN
                RETURN
            END;
            ArcF := OpenArchive(NameList, TRUE);
            err := FALSE;
            IF ArcF = NIL THEN
                RETURN
            ELSE
                IF cmdSource = Menu THEN
                    t := GetText()
                ELSE
                    t := NIL
                END;
                IF t = NIL THEN
                    NEW(t);
                    t := TextFrames.Text("");
                    newViewer := TRUE
                ELSE
                    newViewer := FALSE;
                    Texts.Delete(t, 0, t.len)
                END;
                T := t;
                n := 0;
                totRatio := 0.0;
                Files.Set(R, ArcF, 0);
                ReadHeader(R, h, err);
                WHILE (h.Name # EOFName) & ~err DO
                    WriteString(h.Name);
                    IF opt THEN
                        WriteString("  ");
                        WriteDate(h.time, h.date);
                        WriteString("   ");
                        WriteInt(h.length);
                        WriteString("  ");
                        WriteReal(h.ratio);
                        WriteString("% ")
                    END;
                    WriteLn;
                    INC(n);
                    totRatio := totRatio+h.ratio;
                    Files.Set(R, ArcF, Files.Pos(R)+h.length);
                    ReadHeader(R, h, err)
                END
            END;
            IF ArcF = NIL THEN
                WriteString(NameList.Name);
                WriteString(err2);
                WriteLn;
                RETURN
            END;
            IF Files.Pos(R) = 0 THEN
                WriteString("Archive is empty");
                WriteLn
            ELSE
                WriteLn;
                IF opt & ~err THEN
                    WriteString("Average: ");
                    WriteReal(totRatio/n);
                    WriteString("% ");
                    WriteString(", Size: ");
                    WriteInt(Files.Length(ArcF));
                    WriteString(" Bytes");
                    WriteLn
                END
            END;
            IF err THEN
                WriteString(err1);
                WriteLn
            END;
            IF newViewer THEN
                Oberon.AllocateUserViewer(Oberon.Mouse.X, x, y);
                V := MenuViewers.New(TextFrames.NewMenu(NameList.Name, DirMenu),
                        TextFrames.NewText(t, 0), TextFrames.menuH, x, y);
                V.dsc.next.handle := TextFrames.Handle
            END;
            T := Oberon.Log;
            IF ArcF # NIL THEN Files.Close(ArcF) END
        END Directory;
        PROCEDURE Add*;
            VAR
                nl, NameList: List;
                addL, ha: AddList;
                new, err, changed: BOOLEAN;
                ArcF, AddF: Files.File;
                R: Files.Rider;
                h: Header;
                ver: INTEGER;
                pos, len: LONGINT;
        BEGIN
            GetArgs(NameList);
            IF (NameList = NIL) OR (NameList.next = NIL) THEN
                RETURN
            END;
            new := FALSE;
            ArcF := OpenArchive(NameList, FALSE);
            IF ArcF = NIL THEN
                WriteString("New archive");
                WriteLn;
                new := TRUE;
                ArcF := Files.New(NameList.Name)
            END;
            WriteString("Compress.Add ");
            WriteString(NameList.Name);
            WriteLn;
            changed := FALSE;
            Files.Set(R, ArcF, 0);
            addL := NIL;
            pos := Files.Pos(R);
            ReadHeader(R, h, err);
            WHILE (h.Name # EOFName) & ~err DO
                IF addL = NIL THEN
                    NEW(addL);
                    addL.Name := h.Name;
                    addL.pos := pos;
                    addL.next := NIL
                ELSE
                    NEW(ha);
                    ha.Name := h.Name;
                    ha.pos := pos;
                    ha.next := addL;
                    addL := ha
                END;
                Files.Set(R, ArcF, Files.Pos(R)+h.length);
                pos := Files.Pos(R);
                ReadHeader(R, h, err)
            END;
            IF err THEN
                WriteString(err1);
                WriteLn;
                Files.Close(ArcF);
                RETURN
            END;
            IF NameList.next # NIL THEN
                h.length := 0;
                nl := NameList.next;
                WHILE nl # NIL DO
                    AddF := Files.Old(nl.Name);
                    IF AddF = NIL THEN
                        WriteString("    ");
                        WriteString(nl.Name);
                        WriteString(err2);
                        WriteLn
                    ELSE
                        Trimm(nl.Name);
                        IF (Files.Length(ArcF) + Files.Length(AddF)) >= maxFileSize THEN
                            Files.Close(AddF);
                            nl.next := NIL;
                            WriteString(err3);
                            WriteLn
                        ELSE
                            IF SearchA(addL, nl.Name) # NIL THEN
                                WHILE SearchA(addL, nl.Name) # NIL DO
                                    NextName(nl.Name)
                                END
                            END;
                            Files.Set(R, ArcF, Files.Length(ArcF));
                            pos := Files.Pos(R);
                            COPY(nl.Name, h.Name);
                            WriteString("    ");
                            WriteString(nl.Name);
                            WriteLn;
                            changed := TRUE;
                            h.ratio := 0.0;
                            WriteHeader(R, h, TRUE);
                            len := CopyToArc(AddF, R, h.ratio);
                            h.length := len;
                            Files.Close(AddF);
                            Files.Set(R, ArcF, pos);
                            WriteHeader(R, h, TRUE);
                            NEW(ha);
                            ha.Name := nl.Name;
                            ha.pos := pos;
                            ha.next := addL;
                            addL := ha
                        END
                    END;
                    nl := nl.next
                END
            END;
            IF new THEN
                Files.Register(ArcF)
            ELSE
                Files.Close(ArcF)
            END;
            IF changed & (cmdSource=Menu) THEN Directory END
        END Add;
        PROCEDURE Delete*;
            TYPE
                DelList = POINTER TO DelListDesc;
                DelListDesc = RECORD
                    start, end: LONGINT;
                    next, prev: DelList
                END;
            VAR
                NameList, nl: List;
                DeleteList, last, dl: DelList;
                ArcF, TmpF: Files.File;
                R, Rt: Files.Rider;
                h: Header;
                pos, beg: LONGINT;
                res: INTEGER;
                err, changed: BOOLEAN;
        BEGIN
            GetArgs(NameList);
            IF (NameList = NIL) OR (NameList.next = NIL) THEN
                RETURN
            END;
            ArcF := OpenArchive(NameList, TRUE);
            IF ArcF = NIL THEN
                RETURN
            END;
            DeleteList := NIL;
            last := NIL;
            changed := FALSE;
            WriteString("Compress.Delete ");
            WriteString(NameList.Name);
            WriteLn;
            Files.Set(R, ArcF, 0);
            beg := 0;
            ReadHeader(R, h, err);
            WHILE (h.Name # EOFName) & (NameList.next # NIL) & ~err DO
                pos := Files.Pos(R);
                IF Search(NameList, h.Name) # NIL THEN
                    NEW(dl);
                    dl.start := beg;
                    dl.end := pos+h.length;
                    dl.next := NIL;
                    IF last = NIL THEN
                        DeleteList := dl;
                    ELSE
                        last.next := dl
                    END;
                    last := dl;
                    WriteString("    ");
                    WriteString(h.Name);
                    WriteLn;
                    Remove(NameList, h.Name)
                END;
                Files.Set(R, ArcF, pos+h.length);
                beg := pos+h.length;
                ReadHeader(R, h, err)
            END;
            Files.Close(ArcF);
            nl := NameList.next;
            WHILE nl # NIL DO
                WriteString("    ");
                WriteString(nl.Name);
                WriteString(err2);
                WriteLn;
                nl := nl.next
            END;
            IF err THEN
                WriteString(err1);
                WriteLn
            END;
            IF DeleteList # NIL THEN
                changed := TRUE;
                Files.Rename(NameList.Name, Temp, res);
                ArcF := Files.New(NameList.Name);
                Files.Set(R, ArcF, 0);
                TmpF := Files.Old(Temp);
                Files.Set(Rt, TmpF, 0);
                WHILE DeleteList # NIL DO
                    CopyFrom(Rt, R, DeleteList.start-Files.Pos(Rt));
                    Files.Set(Rt, TmpF, DeleteList.end);
                    DeleteList := DeleteList.next
                END;
                CopyTo(Rt, R);
                Files.Close(TmpF);
                Files.Delete(Temp, res);
                Files.Register(ArcF)
            END;
            IF changed & (cmdSource=Menu) THEN Directory END
        END Delete;
        PROCEDURE Extract*;
            VAR
                NameList: List;
                ArcF, AddF: Files.File;
                R: Files.Rider;
                h: Header;
                pos: LONGINT;
                res: INTEGER;
                err: BOOLEAN;
        BEGIN
            GetArgs(NameList);
            IF (NameList = NIL) OR (NameList.next = NIL) THEN
                RETURN
            END;
            ArcF := OpenArchive(NameList, TRUE);
            IF ArcF = NIL THEN
                RETURN
            END;
            WriteString("Compress.Extract ");
            WriteString(NameList.Name);
            WriteLn;
            Files.Set(R, ArcF, 0);
            ReadHeader(R, h, err);
            WHILE (h.Name # EOFName) & (NameList.next # NIL) & ~err DO
                pos := Files.Pos(R);
                IF Search(NameList, h.Name) # NIL THEN
                    WriteString("    ");
                    WriteString(h.Name);
                    AddF := Files.Old(h.Name);
                    IF AddF # NIL THEN
                        WriteString(" overwriting");
                        Files.Close(AddF);
                        Files.Delete(h.Name, res)
                    END;
                    WriteLn;
                    AddF := Files.New(h.Name);
                    CopyFromArc(R, AddF, h.length);
                    Files.Register(AddF);
                    Remove(NameList, h.Name)
                END;
                Files.Set(R, ArcF, pos+h.length);
                ReadHeader(R, h, err)
            END;
            IF err THEN
                WriteString(err1);
                WriteLn
            END;
            IF NameList.next # NIL THEN
                NameList := NameList.next;
                WHILE NameList # NIL DO
                    WriteString(NameList.Name);
                    WriteString(err2);
                    WriteLn;
                    NameList := NameList.next
                END
            END;
            Files.Close(ArcF)
        END Extract;
        PROCEDURE ExtractAll*;
            VAR
                NameList: List;
                ArcF, AddF: Files.File;
                R: Files.Rider;
                h: Header;
                pos: LONGINT;
                res: INTEGER;
                err: BOOLEAN;
        BEGIN
            GetArgs(NameList);
            IF NameList = NIL THEN
                RETURN
            END;
            ArcF := OpenArchive(NameList, TRUE);
            IF ArcF = NIL THEN
                RETURN
            END;
            WriteString("Compress.ExtractAll ");
            WriteString(NameList.Name);
            WriteLn;
            Files.Set(R, ArcF, 0);
            ReadHeader(R, h, err);
            WHILE (h.Name # EOFName) &  ~err DO
                WriteString("    ");
                WriteString(h.Name);
                pos := Files.Pos(R);
                AddF := Files.Old(h.Name);
                IF AddF # NIL THEN
                    WriteString(" overwriting");
                    Files.Close(AddF);
                    Files.Delete(h.Name, res)
                END;
                WriteLn;
                AddF := Files.New(h.Name);
                CopyFromArc(R, AddF, h.length);
                Files.Register(AddF);
                Files.Set(R, ArcF, pos+h.length);
                ReadHeader(R, h, err)
            END;
            IF err THEN
                WriteString(err1);
                WriteLn
            END;
            Files.Close(ArcF)
        END ExtractAll;
        PROCEDURE Open*;
            VAR
                NameList: List;
                ArcF, AddF: Files.File;
                R: Files.Rider;
                h: Header;
                pos: LONGINT;
                res, x, y: INTEGER;
                err: BOOLEAN;
                t: Texts.Text;
                V: MenuViewers.Viewer;
        BEGIN
            GetArgs(NameList);
            IF NameList = NIL THEN
                RETURN
            ELSIF NameList.next = NIL THEN
                RETURN
            END;
            ArcF := OpenArchive(NameList, TRUE);
            IF ArcF = NIL THEN
                RETURN
            END;
            AddF := NIL;
            Files.Set(R, ArcF, 0);
            ReadHeader(R, h, err);
            WHILE (h.Name # EOFName) &  ~err & (AddF = NIL) DO
                pos := Files.Pos(R);
                IF h.Name = NameList.next.Name THEN
                    AddF := Files.New(Temp);
                    CopyFromArc(R, AddF, h.length);
                    Files.Register(AddF)
                ELSE
                    Files.Set(R, ArcF, pos+h.length);
                    ReadHeader(R, h, err)
                END
            END;
            IF err THEN
                WriteString(err1);
                WriteLn
            END;
            Files.Close(ArcF);
            IF AddF # NIL THEN
                NEW(t);
                t := TextFrames.Text(Temp);
                Oberon.AllocateUserViewer(Oberon.Mouse.X, x, y);
                V := MenuViewers.New(TextFrames.NewMenu(h.Name, EditMenu),
                        TextFrames.NewText(t, 0), TextFrames.menuH, x, y);
                V.dsc.next.handle := TextFrames.Handle;
                Files.Delete(Temp, res)
            ELSE
                WriteString(NameList.next.Name);
                WriteString(err2);
                WriteLn
            END
        END Open;
        PROCEDURE Compile*;
            VAR
                NameList: List;
                ArcF, AddF: Files.File;
                R: Files.Rider;
                h: Header;
                pos: LONGINT;
                res, x, y: INTEGER;
                err: BOOLEAN;
                t: Texts.Text;
                V: MenuViewers.Viewer;
                T: Texts.Text; par: Oberon.ParList; cmd: ARRAY 32 OF CHAR;
        BEGIN
            COPY("Compiler.Compile", cmd);
            NEW(par); par.pos := 0; par.text := TextFrames.Text(""); par.frame := Oberon.Par.frame; par.vwr:= Oberon.Par.vwr;
            GetArgs(NameList);
            IF sym THEN WriteString("Compiler.Compile/s"); WriteLn; END;
            IF NameList = NIL THEN
                RETURN
            ELSIF NameList.next = NIL THEN
                RETURN
            END;
            ArcF := OpenArchive(NameList, TRUE);
            IF ArcF = NIL THEN
                RETURN
            END;
            AddF := NIL;
            Files.Set(R, ArcF, 0);
            ReadHeader(R, h, err);
            WHILE (h.Name # EOFName) & (NameList.next # NIL) & ~err DO
                pos := Files.Pos(R);
                IF Search(NameList, h.Name) # NIL THEN
                    AddF := Files.New(Temp);
                    CopyFromArc(R, AddF, h.length);
                    Files.Register(AddF);
                    Texts.WriteString(W, Temp);
                    IF sym THEN Texts.WriteString(W, "/s") END;
                    Texts.WriteString(W, " ~");
                    Texts.Delete(par.text, 0, par.text.len); Texts.Append(par.text, W.buf);
                    COPY("Compiler.Compile", cmd); Oberon.Call(cmd, par, FALSE, res);
                    Remove(NameList, h.Name)
                END;
                Files.Set(R, ArcF, pos+h.length);
                ReadHeader(R, h, err)
            END;
            IF err THEN
                WriteString(err1);
                WriteLn
            END;
            Files.Close(ArcF);
        END Compile;
    PROCEDURE CompileS*;
    BEGIN
        sym := TRUE; Compile; sym := FALSE;
    END CompileS;
BEGIN
    Texts.OpenWriter(W);
    T := Oberon.Log;
    Texts.WriteString(W, "Compress, EJZ 30.11.94");
    Texts.WriteLn(W);
    Texts.Append(Oberon.Log, W.buf);
    NEW(Tree)
END Compress.